home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / aegis_gc.t < prev    next >
Text File  |  1988-02-05  |  3KB  |  98 lines
  1. (herald aegis_gc (env tsys))
  2.  
  3. ;++ flush this later
  4. (comment
  5.  (define-foreign boot-name_$resolve
  6.     (name_$resolve (in     rep/value        xpname)
  7.                    (in     rep/integer-16-u xpnamlen)
  8.                    (ignore rep/extend       rtn_uid)
  9.                    (out    rep/integer      status))
  10.     ignore)
  11.  
  12. ;++ fix this later -flush boot_name_resolve
  13.  (define (get-uid name len)
  14.   (let ((uid (make-bytev 8)))
  15.     (let ((status (boot-name_$resolve name len uid nil)))
  16.       (if (fxn= status 0)
  17.           (error "boot-name_$resolve failed with status #x~x" status)
  18.           uid))))
  19. )
  20.  
  21. ;++ Temporary definition - flush later
  22. (define unmap-areas true)
  23.  
  24. (define-foreign ms_$truncate
  25.   ("MS_$TRUNCATE" (in  rep/integer address)
  26.                 (in  rep/integer length)
  27.                 (out rep/integer status))
  28.       ignore)
  29.  
  30. (define (zero-out-area area)
  31.   (check-status (ms_$truncate (fx-ashl (area-begin area) 2) 0 nil))
  32.   (no-value))
  33.                                           
  34. (define (initialize-areas)
  35.   (let* ((boot-args (system-global  slink/boot-args))
  36.          (heap-size (vref boot-args 13)))  ; boot/heap-size
  37.     (set *old-space* 
  38.          (create-area 'area2 
  39.                       (vref boot-args 12) ; boot/heap2
  40.                       heap-size
  41.                       nil))             ;++ fix this
  42.     (set *new-space*                            ; current area
  43.          (create-area 'area1 
  44.                       (vref boot-args 9)  ; boot/heap1
  45.                       heap-size
  46.                       nil))             ;++ fix this
  47.     (set (area-base *new-space*)
  48.          (system-global slink/boot-area-base))
  49.     (set (process-global task/area) *new-space*)))
  50.  
  51. (define (gc-message count)
  52.   (vfmt-number "; %D objects copied%." count 0))
  53.  
  54. (define (gc-error-message string address)
  55.   (vfmt "GC error: %A%." (string-text string) (string-length string))
  56.   (vfmt-number "Pointer location #x%H%." (fixnum-ashl address 2) 0)
  57.   (vfmt-number "On into the unknown...%." 0 0))
  58.  
  59. (define-foreign vfmt-number ("VFMT_$WRITE2" (in rep/string)
  60.                                           (in rep/integer)
  61.                                           (in rep/integer))
  62.                             ignore)
  63.  
  64.  
  65. (define-enumerated ms_$advice_opt_t
  66.                     ms_$normal
  67.                     ms_$random
  68.                     ms_$sequential)
  69.  
  70. (define-foreign ms_$advice
  71.   ("MS_$ADVICE" (in rep/integer address)
  72.               (in rep/integer length)
  73.               (in rep/integer access)
  74.               (in rep/integer options)
  75.               (in rep/integer record-length)
  76.               (out rep/integer status))
  77.       ignore)
  78.  
  79. (define (advise-area-access area type)
  80.   (let ((type (if (eq? type 'gc) ms_$sequential ms_$random)))
  81.     (check-status (ms_$advice (fx-ashl (area-begin area) 2)
  82.                               (area-size area)
  83.                               type
  84.                               0
  85.                               0
  86.                               nil))))
  87.  
  88. (define (advise-impure-area-access type)
  89.   (let ((begin (fx-ashl (system-global slink/initial-impure-memory-begin) 2))
  90.         (end   (fx-ashl (system-global slink/initial-impure-memory-end) 2))
  91.         (type  (if (eq? type 'gc) ms_$sequential ms_$random)))
  92.     (check-status (ms_$advice begin
  93.                               (fx- end begin)
  94.                               type
  95.                               0
  96.                               0
  97.                               nil))))
  98.